home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22s.zip / STRINGS2.4TH < prev    next >
Text File  |  1994-10-30  |  3KB  |  98 lines
  1. \ STRING SUPPORT LIBRARY PART  2
  2. \ Contents Copyright (C) 1986 by Thomas Almy
  3.  
  4. \ Permission is granted to registered users of ForthCMP to sell or distribute
  5. \ computer programs incorporating the compiled contents of this file.
  6.  
  7. \ Load this before FORTHLIB
  8.  
  9. .( Loading STRINGS ) CR
  10. 10 DECIMAL DSEG
  11.  
  12. U: STRXTR >R  DUP >R - 0 MAX SWAP R> + SWAP R> MIN ;
  13. U: STRCPY OVER C@ 1+ CMOVE ;
  14. U: ASCIIZ COUNT DUP >R 1+ +STRBUF
  15.     STRBUF R@ CMOVE 0 STRBUF R> + C! STRBUF ;
  16. U: -ASCIIZ DUP 255 0 SCAN DROP OVER - DUP 1+ +STRBUF
  17.     DUP STRBUF C! STRBUF 1+ SWAP CMOVE STRBUF ;
  18. U: -EXT 2DUP -PATH 
  19.    [CHAR] . SCAN  0= IF DROP ELSE NIP OVER - THEN ;
  20. U: +EXT  OVER COUNT -PATH
  21.     [CHAR] . SCAN  0<> IF 2DROP EXIT THEN
  22.     DROP SWAP COUNT ROT COUNT STRCAT STRPCK ;
  23. U: -PATH BEGIN 2DUP  [CHAR] \ SCAN DUP WHILE  
  24.     2SWAP 2DROP   [CHAR] \ SKIP REPEAT 2DROP ;
  25. U: SEARCH 2>R 2DUP BEGIN DUP R@ >= WHILE OVER R@ 2R@ COMPARE 
  26.     0= IF 2R> 2DROP 2SWAP 2DROP 1 EXIT THEN  1 /STRING REPEAT
  27.     2R> 2DROP 2DROP 0 ;
  28. U: COMPARE >R >R ?DS: -ROT ?DS: R> R> STRCMPL ;
  29. U: COMPAREL 
  30.    >R ROT R@ OVER >R MIN cmpl ?DUP IF R> DROP R> DROP EXIT THEN
  31.    R> R> 2DUP > IF 2DROP 1 EXIT THEN
  32.    < ;
  33. SEPDSEG? [IF]
  34. : argc 1 129 128 CS: C@ STR>DSEG 
  35.        BEGIN BL SKIP DUP WHILE BL SCAN ROT 1+ -ROT REPEAT 2DROP ;
  36. [ELSE]
  37. : argc 1 128 COUNT BEGIN BL SKIP DUP WHILE BL SCAN ROT 1+ -ROT REPEAT 2DROP ;
  38. [THEN]
  39.  
  40. ?DEFINE argv [IF]
  41. VARIABLE argvM 1 argvM ! \ constant value
  42. SEPDSEG? [IF]
  43. : argv DUP 1 < IF DROP 44 CS: @ DUP 0 1024 ?DS: argvM 2 STRNDXL
  44.          DUP 0< IF 2DROP 0 0 STRPCK EXIT THEN
  45.          CELL+ -ASCIIZL EXIT THEN
  46.     129 128 CS: C@ STR>DSEG 
  47.     BL SKIP ROT 1- 0 ?DO BL SCAN BL SKIP LOOP
  48.     2DUP BL SCAN DROP NIP OVER - STRPCK ;
  49. [ELSE]
  50. : argv DUP 1 < IF DROP 44 @ DUP 0 1024 ?DS: argvM 2 STRNDXL
  51.          DUP 0< IF 2DROP 0 0 STRPCK EXIT THEN
  52.          CELL+ -ASCIIZL EXIT THEN
  53.     128 COUNT BL SKIP ROT 1- 0 ?DO BL SCAN BL SKIP LOOP
  54.     2DUP BL SCAN DROP NIP OVER - STRPCK ;
  55. [THEN] [THEN]
  56. U: getenv 
  57.    S" ="  STR>DSEG STRCAT 2>R
  58.    44 CS: @ 0 BEGIN  2DUP C@L WHILE
  59.     2DUP ?DS: 2R@ cmpl 0= IF 2R> NIP + -ASCIIZL EXIT THEN
  60.     BEGIN 1+ 2DUP C@L 0= UNTIL 1+ REPEAT 
  61.    2R> 2DROP 2DROP 0 0 STRPCK ;
  62. U: STRCAT DUP  3 PICK + DUP >R +STRBUF
  63.     2 PICK  STRBUF + SWAP CMOVE
  64.     STRBUF SWAP CMOVE STRBUF R> ;
  65. U: STRPCK DUP >R 1+ +STRBUF  STRBUF 1+ R@ CMOVE R> STRBUF C! STRBUF ;
  66. U: -ASCIIZL
  67.     2DUP BEGIN 2DUP C@L WHILE 1+ REPEAT
  68.     NIP OVER - DUP >R 1+ +STRBUF
  69.     ?DS: STRBUF 1+ R@ CMOVEL R> STRBUF C! STRBUF ;
  70. SEPDSEG? [IF]
  71. U: STR>DSEG
  72.    DUP >R +STRBUF  ?CS: SWAP ?DS: STRBUF R@ CMOVEL STRBUF R> ; [ELSE]
  73. U: STR>DSEG  ( DUMMY ) ;
  74. [THEN]
  75. U: +STRBUF DUP strend + strbufr  StringSize + U> IF
  76.       strbufr +  TO strend  strbufr TO STRBUF
  77.     ELSE 
  78.       strend DUP TO STRBUF + TO strend THEN ;
  79. ?DEFINE STRNDX ?DEFINE STRNDXL OR [IF]
  80. VARIABLE strndX 4 ALLOT [THEN]
  81. U: STRNDX TUCK strndX 2!  
  82.    - DUP 0< IF 2DROP -1 EXIT THEN
  83.    -1 -ROT ( save answer )
  84.    1+ 0 DO ?DS: OVER ?DS: strndX 2@ cmpl 0= IF DROP I SWAP LEAVE THEN 1+ LOOP
  85.    DROP ;
  86. U: STRNDXL
  87.     strndX ! strndX CELL+ 2!
  88.     strndX @ - DUP 0< IF 2DROP DROP -1 EXIT THEN
  89.     >R -1 -ROT R>
  90.     1+ 0 DO 2DUP strndX CELL+ 2@ strndX @ cmpl 0= IF DROP I -ROT LEAVE THEN 1+ LOOP
  91.    2DROP ;
  92. UNDEF cmpl
  93. CODE cmpl
  94.   BX POP DX DS <SEG CX POP DI POP ES POPSEG SI POP DS POPSEG
  95.   REPZ BYTE CMPS DX DS >SEG 0 # AX MOV =0 ~ IF,  <0 IF,
  96.    AX DEC ELSE, AX INC THEN, THEN, AX PUSH BX JMP END-CODE [THEN]
  97. 16 = [IF] HEX [THEN]
  98.